Linux Cubed Series 7: Sunsite/Linux Cubed Series 7 - Sunsite Vol 1.iso/system/shells/scsh-0.4/scsh-0/scsh-0.4.2/scsh/oldfr.scm

Text File | 1995-10-13 | 20KB | 569 lines

;;; Field and record parsing utilities for scsh.
;;; Copyright (c) 1994 by Olin Shivers.

;;; Notes:
;;; - Comment on the dependencies here...
;;; - Redefine READ-LINE using READ-DELIMITED.
;;; - Awk should deal with case-insensitivity.
;;; - Should I change the field-splitters to return lists? It's the
;;;   right thing, and costs nothing in terms of efficiency.

;;; Looping primitives:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; It is nicer for loops that loop over a bunch of different things
;;; if you can encapsulate the idea of iterating over a data structure
;;; with a
;;;     (next-element state) -> elt next-state
;;;     (more-elements? state) -? #t/#f
;;; generator/termination-test pair. You can use the generator with REDUCE
;;; to make a list; you can stick it into a loop macro to loop over the
;;; elements. For example, if we had an extensible Yale-loop style loop macro,
;;; we could have a loop clause like
;;;
;;;     (loop (for field in-infix-delimited-string ":" path)
;;;           (do (display field) (newline)))
;;;
;;; and it would be simple to expand this into code using the generator.
;;; With procedural inlining, you can get pretty optimal loops over data
;;; structures this way.
;;;
;;; As of now, you are forced to parse fields into a buffer, and loop
;;; over that. This is inefficient of time and space.  If I ever manage to do
;;; an extensible loop macro for Scheme 48, I'll have to come back to this
;;; package and rethink how to provide this functionality.

;;; Forward-progress guarantees and empty string matches.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; A loop that pulls text off a string by matching a regexp against
;;; that string can conceivably get stuck in an infinite loop if the
;;; regexp matches the empty string. For example, the regexps
;;; ^, $, .*, foo|[^f]* can all match the empty string.
;;;
;;; The regexp-loop routines in this code are careful to handle this case.
;;; If a regexp matches the empty string, the next search starts, not from
;;; the end of the match (which in the empty string case is also the
;;; beginning -- there's the rub), but from the next character over.
;;; This is the correct behaviour. Regexps match the longest possible
;;; string at a given location, so if the regexp matched the empty string
;;; at location i, then it is guaranteed they could not have matched
;;; a longer pattern starting with character #i. So we can safely begin
;;; our search for the next match at char i+1.
;;;
;;; So every iteration through the loop makes some forward progress,
;;; and the loop is guaranteed to terminate.
;;;
;;; This has the effect you want with field parsing. For example, if you split
;;; a string with the empty pattern, you will explode the string into its
;;; individual characters:
;;;     ((suffix-splitter "") "foo") -> #("" "f" "o" "o")
;;; However, even though this boundary case is handled correctly, we don't
;;; recommend using it. Say what you mean -- just use a field splitter:
;;;     ((field-splitter ".") "foo") -> #("f" "o" "o")



;;; (join-strings string-list [delimiter grammar]) => string
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Paste strings together using the delimiter string.
;;;
;;; (join-strings '("foo" "bar" "baz") ":") => "foo:bar:baz"
;;;
;;; DELIMITER defaults to a single space " "
;;; GRAMMAR is one of the symbols {infix, suffix} and defaults to 'infix.

;;; (join-strings strings [delim grammar])

(define (join-strings strings . args)
  (if (pair? strings)
      (receive (delim grammar) (parse-optionals args " " 'infix)
    (check-arg string? delim join-strings)
    (let ((strings (reverse strings)))
      (let lp ((strings (cdr strings))
           (ans (case grammar
              ((infix)  (list (car strings)))
              ((suffix) (list (car strings) delim))
              (else (error "Illegal grammar" grammar)))))
        (if (pair? strings)
        (lp (cdr strings)
            (cons (car strings) (cons delim ans)))

        ; All done
        (apply string-append ans)))))

      ""))    ; Special-cased for infix grammar.

;;; FIELD PARSERS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This section defines routines to split a string into fields.
;;; You can parse by specifying a pattern that *separates* fields,
;;; a pattern that *terminates* fields, or a pattern that *matches*
;;; fields.

(define (->delim-matcher x)
  (if (procedure? x) x                    ; matcher proc
      (let ((re (cond ((regexp? x) x)            ; regexp pattern
              ((string? x) (make-regexp x))    ; regexp string
              (else (error "Illegal pattern/parser" x)))))

    ;; The matcher proc.
    (lambda (s i)
      (cond ((regexp-exec re s i) =>
         (lambda (m) (values (match:start m 0) (match:end m 0))))
        (else (values #f #f)))))))

;;; (infix-splitter         [re num-fields handle-delim])    -> parser
;;; (suffix-splitter        [re num-fields handle-delim])    -> parser
;;; (sloppy-suffix-splitter [re num-fields handle-delim])    -> parser
;;; (field-splitter         [re num-fields])              -> parser
;;;
;;; (parser string [start]) -> string-list

(define (make-field-parser-generator default-delim-matcher loop-proc)
  ;; This is the parser-generator
  (lambda args
    (receive (delim-spec num-fields handle-delim)
         (parse-optionals args  default-delim-matcher #f 'trim)

      ;; Process and error-check the args
      (let ((match-delim (->delim-matcher delim-spec))
        (cons-field (case handle-delim         ; Field     is s[i,j).
              ((trim)            ; Delimiter is s[j,k).
               (lambda (s i j k fields)
                 (cons (substring s i j) fields)))
              ((split)
               (lambda (s i j k fields)
                 (cons (substring s j k)
                   (cons (substring s i j) fields))))
              ((concat)
               (lambda (s i j k fields)
                 (cons (substring s i k)
                   fields)))
              (else
               (error "Illegal handle-delim spec"
                  handle-delim)))))

    (receive (num-fields nfields-exact?)
             (cond ((not num-fields) (values #f #f))
               ((not (integer? num-fields))
            (error "Illegal NUM-FIELDS value" num-fields))
               ((<= num-fields 0) (values (- num-fields) #f))
               (else (values num-fields #t)))

      ;; This is the parser.
      (lambda (s . maybe-start)
        (reverse (loop-proc s (optional-arg maybe-start 0)
                match-delim cons-field
                num-fields nfields-exact?))))))))

(define default-field-matcher (->delim-matcher "[^ \t\n]+"))

;;; (field-splitter [field-spec num-fields])

(define (field-splitter . args)
  (receive (field-spec num-fields)
       (parse-optionals args  default-field-matcher #f)

    ;; Process and error-check the args
    (let ((match-field (->delim-matcher field-spec)))
      (receive (num-fields nfields-exact?)
           (cond ((not num-fields) (values #f #f))
             ((not (integer? num-fields))
              (error "Illegal NUM-FIELDS value"
                 field-splitter num-fields))
             ((<= num-fields 0) (values (- num-fields) #f))
             (else (values num-fields #t)))

    ;; This is the parser procedure.
    (lambda (s . maybe-start)
      (reverse (fieldspec-field-loop s (optional-arg maybe-start 0)
                     match-field num-fields nfields-exact?)))))))


;;; These four procedures implement the guts of each parser
;;; (field, infix, suffix, and sloppy-suffix).
;;;
;;; The CONS-FIELD argument is a procedure that parameterises the
;;; HANDLE-DELIM action for the field parser.
;;;
;;; The MATCH-DELIM argument is used to match a delimiter.
;;; (MATCH-DELIM S I) returns two integers [start, end] marking
;;; the next delimiter after index I in string S. If no delimiter is
;;; found, it returns [#f #f].

;;; In the main loop of each parser, the loop variable LAST-NULL? tells if the
;;; previous delimiter-match matched the empty string. If it did, we start our
;;; next delimiter search one character to the right of the match, so we won't
;;; loop forever. This means that an empty delimiter regexp "" simply splits
;;; the string at each character, which is the correct thing to do.
;;;
;;; These routines return the answer as a reversed list.


(define (fieldspec-field-loop s start match-field num-fields nfields-exact?)
  (let ((end (string-length s)))
    (let lp ((i start) (nfields 0) (fields '()) (last-null? #f))
      (let ((j (if last-null? (+ i 1) i)) ; Where to start next delim search.

        ;; Check to see if we made our quota before returning answer.
        (finish-up (lambda ()
             (if (and num-fields (< nfields num-fields))
                 (error "Too few fields in record." num-fields s)
                 fields))))

    (cond ((> j end) (finish-up))    ; We are done. Finish up.

          ;; Read too many fields. Bomb out.
          ((and nfields-exact? (> nfields num-fields))
           (error "Too many fields in record." num-fields s))

          ;; Made our lower-bound quota. Quit early.
          ((and num-fields (= nfields num-fields) (not nfields-exact?))
           (if (= i end) fields    ; Special case hackery.
           (cons (substring s i end) fields)))

          ;; Match off another field & loop.
          (else (receive (m0 m1) (match-field s j)
                  (if m0 (lp m1 (+ nfields 1)
                 (cons (substring s m0 m1) fields)
                 (=  m0 m1))
              (finish-up)))))))))    ; No more matches. Finish up.


(define (infix-field-loop s start match-delim cons-field
              num-fields nfields-exact?)
  (let ((end (string-length s)))
    (if (= start end) '() ; Specially hack empty string.

    (let lp ((i start) (nfields 0) (fields '()) (last-null? #f))
      (let ((finish-up (lambda ()
                 ;; s[i,end) is the last field. Terminate the loop.
                 (cond ((and num-fields (< (+ nfields 1) num-fields))
                    (error "Too few fields in record."
                       num-fields s))

                   ((and nfields-exact?
                     (>= nfields num-fields))
                    (error "Too many fields in record."
                       num-fields s))

                   (else
                    (cons (substring s i end) fields)))))

        (j (if last-null? (+ i 1) i))) ; Where to start next search.

        (cond
          ;; If we've read NUM-FIELDS fields, quit early .
              ((and num-fields (= nfields num-fields))
           (if nfields-exact?
               (error "Too many fields in record." num-fields s)
               (cons (substring s i end) fields)))


          ((<= j end)        ; Match off another field.
           (receive (m0 m1) (match-delim s j)
             (if m0
             (lp m1 (+ nfields 1)
                 (cons-field s i m0 m1 fields)
                 (= m0 m1))
             (finish-up)))) ; No more delimiters - finish up.

          ;; We've run off the end of the string. This is a weird
          ;; boundary case occuring with empty-string delimiters.
          (else (finish-up))))))))



;;; Match off an optional initial delimiter,
;;; then jump off to the suffix parser.

(define (sloppy-suffix-field-loop s start match-delim cons-field
                  num-fields nfields-exact?)
  ;; If sloppy-suffix, skip an initial delimiter if it's there.
  (let ((start (receive (i j) (match-delim s start)
                 (if (and i (zero? i)) j start))))
    (suffix-field-loop s start match-delim cons-field
               num-fields nfields-exact?)))


(define (suffix-field-loop s start match-delim cons-field
               num-fields nfields-exact?)
  (let ((end (string-length s)))

    (let lp ((i start) (nfields 0) (fields '()) (last-null? #f))
      (let ((j (if last-null? (+ i 1) i))) ; Where to start next delim search.
    (cond ((= i end) ; We are done.
           (if (and num-fields (< nfields num-fields)) ; Didn't make quota.
           (error "Too few fields in record." num-fields s)
           fields))

          ;; Read too many fields. Bomb out.
          ((and nfields-exact? (= nfields num-fields))
           (error "Too many fields in record." num-fields s))

              ;; Made our lower-bound quota. Quit early.
          ((and num-fields (= nfields num-fields) (not nfields-exact?))
           (cons (substring s i end) fields))

          (else ; Match off another field.
           (receive (m0 m1) (match-delim s j)
         (if m0 (lp m1 (+ nfields 1)
                (cons-field s i m0 m1 fields)
                (= m0 m1))
             (error "Missing field terminator" s)))))))))


;;; Now, build the exported procedures: {infix,suffix,sloppy-suffix}-splitter.

(define default-suffix-matcher (->delim-matcher "[ \t\n]+|$"))
(define default-infix-matcher  (->delim-matcher "[ \t\n]+"))

(define infix-splitter
  (make-field-parser-generator default-infix-matcher  infix-field-loop))
(define suffix-splitter
  (make-field-parser-generator default-suffix-matcher suffix-field-loop))
(define sloppy-suffix-splitter
  (make-field-parser-generator default-suffix-matcher sloppy-suffix-field-loop))



;;; Delimited readers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; We repeatedly allocate a buffer and fill it with READ-DELIMITED!
;;; until we hit a delimiter or EOF. Each time through the loop, we
;;; double the total buffer space, so the loop terminates with a log
;;; number of reads, but uses at most double the optimal buffer space.

(define (read-delimited delims . maybe-port)
  (let ((smart-substring (lambda (s end)
               (if (= end (string-length s)) s
                   (substring s 0 end))))
    (delims (->char-set delims)))

    ;; BUFLEN is total amount of buffer space allocated to date.
    (let lp ((strs '()) (buflen 80) (buf (make-string 80)))
      (cond ((apply read-delimited! delims buf maybe-port) =>
             (lambda (i)
           (if (null? strs)        ; Gratuitous optimisation.
           (smart-substring buf i)
           (apply string-append
              (reverse (if (eof-object? i)
                       strs
                       (cons (smart-substring buf i)
                         strs)))))))

        (else (lp (cons buf strs)
              (+ buflen buflen)
              (make-string buflen)))))))


;;; (read-delimited! delims buf [port start end])

(define (read-delimited! delims buf . args) ; [port start end]
  (receive (port start end)
       (parse-optionals args (current-input-port) 0 (string-length buf))
    (check-arg input-port? port read-delimited!)
    (let ((delims (->char-set delims)))
;      (if (fd-inport? port) ; ???
;
;      ;; Handle fdports in C code for speed.
;      (receive (err val)
;           (%read-delimited-fdport!/errno delims buf port start end)
;        (if err
;            (errno-error err read-delimited!)
;            val))

      ;; This is the code for other kinds of ports.
      (let lp ((i start))
        (and (< i end)
             (let ((c (peek-char port)))
           (if (or (eof-object? c)
               (char-set-contains? delims c))
               (- i start)
               (begin (string-set! buf i (read-char port))
                  (lp (+ i 1))))))))))
;)

;(define-foreign %read-delimited-fdport!/errno (read_delim (string-desc delims)
;                              (string-desc buf)
;                              (desc port) ;???
;                              (fixnum start)
;                              (fixnum end))
;  desc    ; errno or #f
;  desc)    ; nread or #f or eof-object

(define (skip-char-set cset . maybe-port)
  (let ((port (optional-arg maybe-port (current-input-port))))
    (let lp ()
      (let ((c (peek-char port)))
    (cond ((and (char? c) (char-set-contains? cset c))
           (read-char port)
           (lp))
          (else c))))))



;;; Reading records
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define default-record-delims (char-set #\newline))

;;; (record-reader [delims elide? handle-delim]) -> reader
;;; (reader [port]) -> string or eof

(define (record-reader . args)
  (receive (delims elide? handle-delim)
           (parse-optionals args default-record-delims #f 'trim)
    (let ((delims (->char-set delims)))

      (case handle-delim
    ((trim)            ; TRIM-delimiter reader.
     (lambda maybe-port
       (let ((s (apply read-delimited delims maybe-port)))
         (if (not (eof-object? s))
         (if elide?
             (apply skip-char-set delims maybe-port) ; Snarf delims.
             (apply read-char maybe-port))) ; Just snarf one.
         s)))

    ((concat split)        ; CONCAT-delimiter & SPLIT-delimiter reader.
     (let ((not-delims (char-set-invert delims)))
       (lambda maybe-port
         (let ((s (apply read-delimited delims maybe-port)))
           (if (eof-object? s) s
           (let ((delim (if elide?
                    (apply read-delimited not-delims maybe-port)
                    (string (apply read-char maybe-port)))))
             (if (eq? handle-delim 'split)
             (values s delim)
             (if (eof-object? delim) s
                 (string-append s delim)))))))))

    (else
     (error "Illegal delimiter-action" handle-delim))))))


;;; {string, char, char-set, char predicate} -> char-set

(define (->char-set x)
  (cond ((char-set? x) x)
    ((string? x) (string->char-set x))
    ((char? x) (char-set x))
    ((procedure? x) (predicate->char-set x))
    (else (error "->char-set: Not a charset, string, char, or predicate."
             x))))



(define blank-line-regexp (make-regexp "^[ \t]*\n$"))

;;; (read-paragraph [port])
(define (read-paragraph . maybe-port)
  (let ((port (optional-arg maybe-port (current-input-port))))

    ;; First, skip all blank lines.
    (let lp ()
      (let ((line (read-line port #t)))
    (cond ((eof-object? line)                   line)
          ((regexp-exec blank-line-regexp line) (lp))

          ;; Then, read in non-blank lines.
          (else (let ((lines (let lp ((lines (list line)))
                   (let ((line (read-line port #t)))
                     (cond ((or (eof-object? line)
                        (regexp-exec blank-line-regexp
                                 line))
                        lines)
                       (else (lp (cons line lines))))))))

              ;; Return the paragraph
              (apply string-append (reverse lines)))))))))

;;; Reading and parsing records
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; (field-reader [field-parser rec-reader]) -> reader
;;; (reader [port]) -> [raw-record parsed-record] or [eof #()]
;;;
;;; This is the field reader, which is basically just a composition of
;;; RECORD-READER and FIELD-PARSER.

(define default-field-parser (field-splitter))

(define (field-reader . args)
  (receive (parser rec-reader)
           (parse-optionals args default-field-parser read-line)
    (lambda maybe-port
      (let ((record (apply rec-reader maybe-port)))
    (if (eof-object? record)
        (values record '#())
        (values record (parser record)))))))



;;; Parse fields by regexp
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This code parses up a record into fields by matching a regexp specifying
;;; the field against the record. The regexp describes the *field*. In the
;;; other routines, the regexp describes the *delimiters*. They are
;;; complimentary.

;;; Repeatedly do (APPLY PROC M STATE) to generate new state values,
;;; where M is a regexp match structure made from matching against STRING.

;(define (regexp-reduce string start regexp proc . state)
;  (let ((end (string-length string))
;    (regexp (if (string? regexp)
;            (make-regexp regexp)
;            regexp)))
;
;    (let lp ((i start) (state state) (last-null? #f))
;      (let ((j (if last-null? (+ i 1) i)))
;    (cond ((and (<= j end) (regexp-exec regexp string j)) =>
;               (lambda (m)
;         (receive state (apply proc m state)
;           (lp (match:end m) state (= (match:start m) (match:end m))))))
;          (else (apply values state)))))))
;
;(define (all-regexp-matches regexp string)
;  (reverse (regexp-reduce string 0 regexp
;              (lambda (m ans) (cons (match:substring m 0) ans))
;              '())))

;;; Previously in newports.scm

;;; Read in a line of data. Input is terminated by either a newline or EOF.
;;; The newline is trimmed from the string.

(define (read-line . rest)
  (let ((port (if (null? rest) (current-input-port) (car rest))) ; Optional arg
    (retain-newline? (and (not (null? rest))         ; parsing.
                  (not (null? (cdr rest)))
                  (cadr rest)))

    ;; S[I] := C. If this overflows S, grow it.
    (deposit (lambda (s i c)
           (let ((s (if (< i (string-length s)) s
                (string-append s s)))) ; doubling hack
             (string-set! s i c)
             s)))

    ;; Precisely resize S to size NUMCHARS.
    (trim (lambda (s numchars)
        (if (= numchars (string-length s)) s
            (substring s 0 numchars)))))

    (let lp ((s (make-string 81)) (numchars 0))
      (let ((c (read-char port)))
    (cond ((eof-object? c)
           (if (zero? numchars) c
           (trim s numchars)))

          ((char=? c #\newline)
           (if retain-newline?
           (trim (deposit s numchars c)
             (+ numchars 1))
           (trim s numchars)))

          (else (lp (deposit s numchars c)
            (+ numchars 1))))))))